;;; set.ss  --  Guilleaume Marceau / Jens Axel Søgaard

;;; HISTORY

; 26 june 2005 
;  - Initial implementation of new layer /marceau
; 27 june 2005
;  -Modified in order to support two APIs. /soegaard
;  Changed names, so (make-set) displays #<struct:<set>> in repl  /soegard
;  Eliminated the overhead of 'apply' in 'invoke'  (invoke is now called 'call')  /soegaard

(module set mzscheme
  (provide make-set
           make-set/fn
           make-set/implementation
           set?
           set-empty?
           ; set-fold
           set-insert
           set-insert-all
           set-remove
           set-remove-all
           set-member?
           set-get
           set-filter
           set-union
           set-intersection
           set-difference
           set-subset?
           set-equal?
           set-size
           set-elements)

  (require (lib "etc.ss")
           (lib "unitsig.ss")
           (lib "list.ss")
           "../set.ss")

  
  ; A general set consists of a "vector" of methods, a size and a specialized
  ; representation of the set.

  (define-struct <set> 
    (methods   ; the set methods
     set       ; the specialized set representation
     ))

  (define (set? o) (<set>? o))

  
  (define-struct set-methods 
    ; IMPORTANT: When adding more methods, remember to add a keyword in 'call' below
    (empty? insert insert-all remove remove-all member? get fold 
           union filter intersection difference
           subset? equal? size elements))

  ; (call method-name methods . arguments) 
  ;   sugar coats the method calls
  ;   (this is more effective than using a call to
  ;      (define (invoke t field-fn . args)
  ;        (make-tt (tt-fns t) (apply (field-fn (tt-fns t)) args)))
  ;    since invoke uses apply uses apply at runtime.) 
  (define-syntax call
    (syntax-rules (empty? insert insert-all remove remove-all member? get fold 
                   union filter intersection difference
                   subset? equal? size elements)
      ((call m empty?       s)     ((set-methods-empty?                 m) s))
      ((call m insert       s x)   ((set-methods-insert                 m) s x))
      ((call m insert-all   s xs)  ((set-methods-insert-all             m) s xs))
      ((call m remove       s x)   ((set-methods-remove                 m) s x))
      ((call m remove-all   s xs)  ((set-methods-remove-all             m) s xs))
      ((call m member?      s x)   ((set-methods-member?                m) s x))
      ((call m get          s x)   ((set-methods-get                    m) s x))
      ((call m fold         s f i) ((set-methods-fold                   m) s f i))
      ((call m union        s1 s2) ((set-methods-union                  m) s1 s2))
      ((call m filter       s f)   ((set-methods-filter                 m) s f))
      ((call m intersection s1 s2) ((set-methods-intersection           m) s1 s2))
      ((call m difference   s1 s2) ((set-methods-difference             m) s1 s2))
      ((call m subset?      s1 s2) ((set-methods-subset?                m) s1 s2))
      ((call m equal?       s1 s2) ((set-methods-equal?                 m) s1 s2))
      ((call m size         s)     ((set-methods-size                   m) s))
      ((call m elements     s)     ((set-methods-elements               m) s))
      ((_ . more)                
       (error "call: unknown <set> method: " '(call . more)))))


  (define make-set
    (opt-lambda ([set@ unbalanced-search-tree-set@]
                 [order@ eq-hash-order@])
      (use-set (instantiate-set set@ order@))
      (make-<set> (make-set-methods empty? insert insert-all remove remove-all member? get fold 
                                    union filter intersection difference
                                    subset? equal? size elements)
                  empty)))
  

  (define make-set/fn
    (opt-lambda (elm<
                 [set@ unbalanced-search-tree-set@]
                 [elm= (lambda (a b) (and (not (elm< a b)) (not (elm< b a))))])
      (let ([_elm< elm<]
            [_elm= elm=]
            [_elm<= (lambda (a b) (or (elm< a b) (elm= a b)))])
      (make-set set@ (predicates->ordered _elm= _elm< _elm<=)))))


  (define make-set/implementation 
    (opt-lambda (empty empty? insert remove member? get fold)
      (define (xinsert x s)
        (insert s x))
      (define (insert-all t elms)
        (foldl xinsert t elms))
      (define (xremove x s)
        (remove s x))
      (define (remove-all t elms)
        (foldl xremove t elms))
      (define (union s1 s2)
        (foldl xinsert s2 s1))
      (define (filter p? s)
        (foldl (lambda (x s)
                 (if (p? x)
                     (insert s x)
                     s))
               empty s))
      (define (intersection s1 s2)
        (filter (lambda (x) (member? s2 x))
                s1))
      (define (difference s1 s2)
        (filter (lambda (x) (not (member? s2 x)))
                s1))
      (define (subset? s1 s2)
        (let/ec return
          (foldl (lambda (x p?)
                   (if (p? x)
                       (member? s2 x)
                       (return #f)))
                 #t s1)))
      (define (equal? s1 s2)
        (and (subset? s1 s2)
             (subset? s2 s1)))
      (define (size s)
        (foldl (lambda (x n) (add1 n))
               0 s))
      (define (elements s)
        (foldl cons empty s))
      
      (make-<set> (make-set-methods empty? insert insert-all remove remove-all member? get fold 
                                    union filter intersection difference
                                    subset? equal? size elements)
                  empty)))
  

  (define-syntax with-set 
    (syntax-rules ()
      [(with-set () body)
       body]
      [(with-set ((s m d)) body)
       (let ((m (<set>-methods s))
             (d (<set>-set s)))
         body)]
      [(with-set ((s m d) . more) body)
       (with-set ((s m d))
                 (with-set more
                           body))]))
  
  
  (define (set-empty? s)           (with-set ((s m d)) (call m empty?   d)))
  (define (set-member? s x)        (with-set ((s m d)) (call m member?  d x)))
  (define (set-get s x)            (with-set ((s m d)) (call m get      d x)))
  (define (set-size s)             (with-set ((s m d)) (call m size     d)))
  (define (set-elements s)         (with-set ((s m d)) (call m elements d)))

  (define (set-insert s x)         (with-set ((s m d)) (make-<set> m (call m insert       d x))))
  (define (set-insert-all s x)     (with-set ((s m d)) (make-<set> m (call m insert-all   d x))))
  (define (set-remove s x)         (with-set ((s m d)) (make-<set> m (call m remove       d x))))
  (define (set-remove-all s x)     (with-set ((s m d)) (make-<set> m (call m remove-all   d x))))
  (define (set-filter fn s)        (with-set ((s m d)) (make-<set> m (call m filter fn    d))))

  (define (set-union s1 s2)        (with-set ((s1 m1 d1) (s2 m2 d2)) (make-<set> m1 (call m1 union        d1 d2))))
  (define (set-intersection s1 s2) (with-set ((s1 m1 d1) (s2 m2 d2)) (make-<set> m1 (call m1 intersection d1 d2))))
  (define (set-difference s1 s2)   (with-set ((s1 m1 d1) (s2 m2 d2)) (make-<set> m1 (call m1 difference   d1 d2))))
  (define (set-subset? s1 s2)      (with-set ((s1 m1 d1) (s2 m2 d2))                (call m1 subset?      d1 d2)))
  (define (set-equal? s1 s2)       (with-set ((s1 m1 d1) (s2 m2 d2))                (call m1 equal?       d1 d2)))
;  (define (set-fold fn init s)   (with-set s m d                (call m fold fn (d init) s))

  
  
;  > (syntax-object->datum (expand '(define (set-equal? s1 s2) (with-set ((s1 m1 d1) (s2 m2 d2)) (call m1 equal? d1 d2)))))
;(define-values
;  (set-equal?)
;  (lambda (s1 s2)
;    (let-values (((m1) (#%app (#%top . <set>-methods) s1)) ((d1) (#%app (#%top . <set>-set) s1)))
;      (let-values (((m2) (#%app (#%top . <set>-methods) s2)) ((d2) (#%app (#%top . <set>-set) s2)))
;        (#%app (#%app (#%top . set-methods-equal?) m1) d1 d2)))))

  (define (test)
    (printf "~a~n"
            (set-elements (set-remove-all (set-insert-all (make-set/fn <) '(1 2 3 4 5)) '(2 3)))))

  (test)
)
;
;(require set)

;(define empty-set (make-set))
;(define A1 (set-insert empty-set 1))
;(define A2 (set-insert A1 2))
;(define A3 (set-insert A2 3))
;(define A4 (set-insert A3 4))
;(set-elements A4)
;
;(set-elements (set-union (set-insert-all empty-set (list 1 2 3 4))
;                         (set-insert-all empty-set (list 3 4 5 6))))

;; The following shows that (make-set) returns different empty 
;; sets (because define-struct is generative) each time it is called

;(set-elements (set-union (set-insert-all (make-set) (list 1 2 3 4))
;                          set-insert-all (make-set) (list 3 4 5 6))))